home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / nexttsrc.lha / nexttsources / sources / sys / sym_printer.t < prev    next >
Text File  |  1988-02-05  |  5KB  |  126 lines
  1. (herald symbol_printer 
  2.   (env tsys (osys symbol) 
  3.             (osys readtable)))
  4.  
  5. ;;; Fancy symbol printer.  It handles slashification.  The fancy
  6. ;;; symbol printer attempts to print the symbol using minimum number
  7. ;;; of characters under the constraint of rereadability.
  8.  
  9. (define fancy-symbol-printing?
  10.   (let ((val t))
  11.     (object (lambda () val)
  12.       ((setter self)
  13.        (lambda (val)
  14.          (let ((val (enforce boolean? val)))
  15.            (if val
  16.                (set *write-symbol* fancy-write-symbol)
  17.                (set *write-symbol* plain-write-symbol))))))))
  18.  
  19. (define-constant special-initials "-+!$%&*/:<=>?~_^")
  20.  
  21. (define (special-initial? ch)
  22.   (string-posq ch special-initials))
  23.  
  24. (define-integrable (escaped-initial? symbol)
  25.   (let ((ch (symbol-elt symbol %%symbol-text-offset)))
  26.     (not (or (uppercase? ch)
  27.              (special-initial? ch)))))
  28.  
  29. ; scheme doesn't allow "-" or "+" as an initial.
  30. ;            (and (fx= (symbol-length symbol)
  31. ;                      (fx+ %%symbol-text-offset 1))
  32. ;                 (sign-char? ch))))))
  33.  
  34. (define (fancy-write-symbol port symbol)
  35.   (receive (i escape?)
  36.            (cond ((fx= 0 (symbol-length symbol))
  37.                   (return %%symbol-text-offset t))
  38.                  ((escaped-initial? symbol)
  39.                   (return (fx+ %%symbol-text-offset 1) t))
  40.                  (else
  41.                   (return %%symbol-text-offset nil)))
  42.     (iterate loop ((i i) (escape? escape?) (delimit? '#f))
  43.       (cond ((fx>= i (symbol-length symbol))
  44.              (cond (delimit? (write-delimited-symbol port symbol escape?))
  45.                    (escape?  (write-escaped-symbol   port symbol))
  46.                    (else     (plain-write-symbol  port symbol)))
  47.              (no-value))
  48.             (else
  49.              (let* ((ch (symbol-elt symbol i))
  50.                     (e  (char-syntax *print-table* ch)))
  51.                (select e
  52.                  ((%%constituent)
  53.                   (cond ((neq? ch ((rt-translator *print-table*) ch))
  54.                          (loop (fx+ i 1) '#t delimit?))
  55.                         (else
  56.                          ;; this is the most important case ...
  57.                          (loop (fx+ i 1) escape? delimit?))))
  58.                  ((%%escape-char)
  59.                   (loop (fx+ i 1) '#t delimit?))
  60.                  ((%%whitespace %%ignored %%undefined)
  61.                   (loop (fx+ i 1) escape? '#t))
  62.                  (else
  63.                   ;; read macro.
  64.                   (cond ((or (not (constituent-syntax? e))
  65.                              (fx= i 0))
  66.                          (loop (fx+ i 1) '#t delimit?))
  67.                         (else
  68.                          (loop (fx+ i 1) escape? delimit?)))))))))))
  69.  
  70.  
  71. ;;; The symbol has no funny characters, but if it were printed using
  72. ;;; PLAIN-WRITE-SYMBOL then it would be re-read as a number or
  73. ;;; some random thing.
  74.  
  75. (define (write-delimited-symbol port symbol escaped?)
  76.   (cond (*symbol-delimiter*
  77.          (writec port *symbol-delimiter*)
  78.          (if escaped?
  79.              (write-escaped-symbol port symbol)
  80.              (plain-write-symbol port symbol))
  81.          (writec port *symbol-delimiter*))
  82.         (else
  83.          (write-losing-symbol port symbol))))
  84.  
  85. ;;; Try to print symbol, escaping any characters which can't be
  86. ;;; reread for one reason or another.
  87.  
  88. (define (write-escaped-symbol port symbol)
  89.   (let ((len (symbol-length symbol))
  90.         (writec (if (iob? port) vm-write-char write-char)))
  91.     (cond (*escape-char*
  92.            ;; we know it's a symbol.
  93.            (if (and (fx>= len 1) (escaped-initial? symbol))
  94.                (writec port *escape-char*))
  95.            (writec port (symbol-elt symbol %%symbol-text-offset))
  96.            (iterate loop ((i (fx+ %%symbol-text-offset 1)))
  97.              (cond ((fx>= i len) (no-value))
  98.                    (else
  99.                     ;++ what about control characters?
  100.                     (let* ((ch  (symbol-elt symbol i))
  101.                            (syn (char-syntax *print-table* ch)))
  102.                       (cond ((or (not (constituent-syntax? syn))         ; e.g. \(
  103.                                  (and (not (fixnum? syn)) (fx= i 0))     ; e.g. \'x
  104.                                  (neq? ch ((rt-translator *print-table*) ch))) ; e.g. \x
  105.                              (writec port *escape-char*)
  106.                              (writec port ch))
  107.                             (*translate-constituent-inverse*
  108.                              (writec port (*translate-constituent-inverse* ch)))
  109.                             (else
  110.                              (writec port ch))))
  111.                     (loop (fx+ i 1))))))
  112.           (*symbol-delimiter*
  113.            (writec port *symbol-delimiter*)
  114.            (plain-write-symbol port symbol)
  115.            (writec port *symbol-delimiter*))
  116.           (else
  117.            (write-losing-symbol port symbol)))))
  118.  
  119. ;;; We use this routine when none of the above strategies is
  120. ;;; appropriate.
  121.  
  122. (define (write-losing-symbol port symbol)
  123.   (write-string port "#[Symbol \"")
  124.   (write-string port (symbol->string symbol))
  125.   (write-string port "\"]"))
  126.